home *** CD-ROM | disk | FTP | other *** search
/ Collection of Tools & Utilities / Collection of Tools and Utilities.iso / ada / gnat1792.zip / gnat179b / t-adainc / s-tasabo.adb < prev    next >
Text File  |  1994-05-19  |  9KB  |  251 lines
  1. ------------------------------------------------------------------------------
  2. --                                                                         --
  3. --                GNU ADA RUNTIME LIBRARY (GNARL) COMPONENTS               --
  4. --                                                                         --
  5. --              S Y S T E M . T A S K I N G . A B O R T I O N              --
  6. --                                                                         --
  7. --                                 B o d y                                 --
  8. --                                                                         --
  9. --                            $Revision: 1.6 $                             --
  10. --                                                                         --
  11. --          Copyright (c) 1991,1992,1993, FSU, All Rights Reserved         --
  12. --                                                                         --
  13. --  GNARL is free software; you can redistribute it and/or modify it  under --
  14. --  terms  of  the  GNU  Library General Public License as published by the --
  15. --  Free Software Foundation; either version 2,  or (at  your  option)  any --
  16. --  later  version.   GNARL is distributed in the hope that it will be use- --
  17. --  ful, but but WITHOUT ANY WARRANTY; without even the implied warranty of --
  18. --  MERCHANTABILITY  or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU Gen- --
  19. --  eral Library Public License for more details.  You should have received --
  20. --  a  copy of the GNU Library General Public License along with GNARL; see --
  21. --  file COPYING. If not, write to the Free Software Foundation,  675  Mass --
  22. --  Ave, Cambridge, MA 02139, USA.                                          --
  23. --                                                                         --
  24. ------------------------------------------------------------------------------
  25.  
  26. with System.Tasking.Runtime_Types;
  27. --  Used for, Runtime_Types.ID_To_ATCB,
  28. --            Runtime_Types.ATCB_To_ID,
  29. --            Runtime_Types.ATCB_Ptr,
  30. --            Runtime_Types.Terminated,
  31. --            Runtime_Types.Not_Accepting,
  32. --            Runtime_Types.All_Tasks_L,
  33. --            Runtime_Types.All_Tasks_List
  34.  
  35. with System.Tasking.Rendezvous;
  36. --  Used for, Complete_on_Sync_Point
  37.  
  38. with System.Task_Primitives; use System.Task_Primitives;
  39.  
  40. package body System.Tasking.Abortion is
  41.  
  42.    function ID_To_ATCB (ID : Task_ID) return Runtime_Types.ATCB_Ptr
  43.      renames Runtime_Types.ID_To_ATCB;
  44.  
  45.    function ATCB_To_ID (Ptr : Runtime_Types.ATCB_Ptr) return Task_ID
  46.      renames Runtime_Types.ATCB_To_ID;
  47.  
  48.    function "=" (L, R : Runtime_Types.Task_Stage) return Boolean
  49.      renames Runtime_Types."=";
  50.  
  51.    function "=" (L, R : Runtime_Types.ATCB_Ptr) return Boolean
  52.      renames Runtime_Types."=";
  53.  
  54.    function "=" (L, R : Runtime_Types.Accepting_State) return Boolean
  55.      renames Runtime_Types."=";
  56.  
  57.    --------------------
  58.    -- Defer_Abortion --
  59.    --------------------
  60.  
  61.    procedure Defer_Abortion is
  62.       T : Runtime_Types.ATCB_Ptr := ID_To_ATCB (Self);
  63.  
  64.    begin
  65.       T.Deferral_Level := T.Deferral_Level + 1;
  66.    end Defer_Abortion;
  67.  
  68.    ----------------------
  69.    -- Undefer_Abortion --
  70.    ----------------------
  71.  
  72.    --  Precondition : Self does not hold any locks!
  73.  
  74.    procedure Undefer_Abortion is
  75.       T : Runtime_Types.ATCB_Ptr := ID_To_ATCB (Self);
  76.  
  77.    begin
  78.       T.Deferral_Level := T.Deferral_Level - 1;
  79.  
  80.       if T.Deferral_Level = ATC_Level'First and then
  81.         T.Pending_ATC_Level < T.ATC_Nesting_Level
  82.       then
  83.          T.Deferral_Level := T.Deferral_Level + 1; -- go away w/GNARLI 1.28???
  84.          raise Standard'Abort_Signal;
  85.       end if;
  86.  
  87.    end Undefer_Abortion;
  88.  
  89.    --------------------
  90.    -- Abort_To_Level --
  91.    --------------------
  92.  
  93.    procedure Abort_To_Level
  94.      (Target : Task_ID;
  95.       L      : ATC_Level)
  96.    is
  97.       T : Runtime_Types.ATCB_Ptr := ID_To_ATCB (Target);
  98.  
  99.    begin
  100.       Write_Lock (T.L);
  101.  
  102.       if T.Pending_ATC_Level > L then
  103.          T.Pending_ATC_Level := L;
  104.  
  105.          if not T.Aborting then
  106.             T.Aborting := True;
  107.  
  108.             if T.Suspended_Abortably then
  109.                Cond_Signal (T.Cond);
  110.                Cond_Signal (T.Rend_Cond);
  111.  
  112.                --  Ugly; think about ways to have tasks suspend on one
  113.                --  condition variable. ???
  114.  
  115.             else
  116. --               if Same_Task (Target, Self) then    ???
  117.  
  118.                if Target =  Self then
  119.                   Unlock (T.L);
  120.                   Abort_Task (T.LL_TCB'access);
  121.                   return;
  122.  
  123.                elsif T.Stage /= Runtime_Types.Terminated then
  124.                   Abort_Task (T.LL_TCB'access);
  125.                end if;
  126.  
  127.                --  If this task is aborting itself, it should unlock itself
  128.                --  before calling abort, as it is unlikely to have the
  129.                --  opportunity to do so afterwords. On the other hand, if
  130.                --  another task is being aborted, we want to make sure it is
  131.                --  not terminated, since there is no need to abort a terminated
  132.                --  task, and it may be illegal if it has stopped executing.
  133.                --  In this case, the Abort_Task must take place under the
  134.                --  protection of the mutex, so we know that Stage/=Terminated.
  135.  
  136.             end if;
  137.          end if;
  138.       end if;
  139.  
  140.       Unlock (T.L);
  141.  
  142.    end Abort_To_Level;
  143.  
  144.    -------------------
  145.    -- Abort_Handler --
  146.    -------------------
  147.  
  148.    procedure Abort_Handler
  149.      (Context : Task_Primitives.Pre_Call_State)
  150.    is
  151.       T : Runtime_Types.ATCB_Ptr := ID_To_ATCB (Self);
  152.  
  153.    begin
  154.       if T.Deferral_Level = 0
  155.         and then T.Pending_ATC_Level < T.ATC_Nesting_Level
  156.       then
  157.          raise Standard'Abort_Signal;
  158.  
  159.          --  Not a good idea; signal remains masked after the Abortion ???
  160.          --  exception is handled.  There are a number of solutions :
  161.          --  1. Change the PC to point to code that raises the exception and
  162.          --     then jumps to the location that was interrupted.
  163.          --  2. Longjump to the code that raises the exception.
  164.          --  3. Unmask the signal in the Abortion exception handler
  165.          --     (in the RTS).
  166.       end if;
  167.    end Abort_Handler;
  168.  
  169.    ----------------------
  170.    -- Abort_Dependents --
  171.    ----------------------
  172.  
  173.    --  Process abortion of child tasks.
  174.  
  175.    --  Abortion should be dererred when calling this routine.
  176.    --  No mutexes should be locked when calling this routine.
  177.  
  178.    procedure Abort_Dependents (Abortee : Task_ID) is
  179.       Temp_T                : Runtime_Types.ATCB_Ptr;
  180.       Temp_P                : Runtime_Types.ATCB_Ptr;
  181.       Old_Pending_ATC_Level : ATC_Level_Base;
  182.       TAS_Result            : Boolean;
  183.       A                     : Runtime_Types.ATCB_Ptr := ID_To_ATCB (Abortee);
  184.  
  185.    begin
  186.       Write_Lock (Runtime_Types.All_Tasks_L);
  187.       Temp_T := Runtime_Types.All_Tasks_List;
  188.  
  189.       while Temp_T /= null loop
  190.          Temp_P := Temp_T.Parent;
  191.  
  192.          while Temp_P /= null loop
  193.             exit when Temp_P = A;
  194.             Temp_P := Temp_P.Parent;
  195.          end loop;
  196.  
  197.          if Temp_P = A then
  198.             Temp_T.Accepting := Runtime_Types.Not_Accepting;
  199.  
  200.             --  Send cancel signal.
  201.             Rendezvous.Complete_on_Sync_Point (ATCB_To_ID (Temp_T));
  202.             Abort_To_Level (ATCB_To_ID (Temp_T), 0);
  203.          end if;
  204.  
  205.          Temp_T := Temp_T.All_Tasks_Link;
  206.       end loop;
  207.  
  208.       Unlock (Runtime_Types.All_Tasks_L);
  209.  
  210.    end Abort_Dependents;
  211.  
  212.    -----------------
  213.    -- Abort_Tasks --
  214.    -----------------
  215.  
  216.    --  Called to initiate abortion, however, the actual abortion
  217.    --  is done by abortee by means of Abort_Handler
  218.  
  219.    procedure Abort_Tasks (Tasks : Task_List) is
  220.       Abortee               : Runtime_Types.ATCB_Ptr;
  221.       Aborter               : Runtime_Types.ATCB_Ptr;
  222.       Activator             : Runtime_Types.ATCB_Ptr;
  223.       TAS_Result            : Boolean;
  224.       Old_Pending_ATC_Level : ATC_Level_Base;
  225.  
  226.    begin
  227.       Defer_Abortion;
  228.  
  229.       --  Begin non-abortable section
  230.  
  231.       Aborter := ID_To_ATCB (Self);
  232.  
  233.       for J in Tasks'range loop
  234.          Abortee := ID_To_ATCB (Tasks (J));
  235.          Abortee.Accepting := Runtime_Types.Not_Accepting;
  236.